perm filename XAP4[XAP,BGB] blob
sn#047862 filedate 1973-06-06 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00019 PAGES
C REC PAGE DESCRIPTION
C00001 00001 VALID 00013 PAGES
C00003 00002 SUBR(DEFONT) DEFINE FONT N.
C00005 00003 SUBR(SETFNT) SETUP A FONT.
C00007 00004 FONT SELECT DELIMITERS.
C00009 00005 --- ASCII 00 TO 37.
C00010 00006 --- ASCII 40 TO 77.
C00011 00007 --- ASCII 100 TO 137. UPPER CASE COMMANDS.
C00013 00008 --- ASCII 140 TO 177. LOWER CASE COMMANDS.
C00014 00009 COMMAND EXECUTION.
C00016 00010 XRADIAL:
C00018 00011 III DISPLAY SCALE FACTOR.
C00020 00012 SUBR(MODE0)
C00025 00013 SUBR(SQRT)
C00027 00014 BEGIN SINCOS SINE & COSINE - BGB.
C00029 00015 SUBR(REALIN)
C00032 00016 SUBR(DPYDOT)X,Y DISPLAY A DOT.
C00033 00017 SUBR(MKSEG3)
C00034 00018 SUBR(XCONIC) E<A>,<B>,<X1>,<X2>
C00035 00019 SUBR(MKCURV)
C00036 ENDMK
C⊗;
SUBR(DEFONT) DEFINE FONT N.
BEGIN DEFONT;_____________________________________________________
DZM FILNAM
;DISK INITIALIZATION.
INIT 1,17↔SIXBIT/DSK/↔0
GO[FATAL(CAN'T INIT DSK)]↔DAC 1,FONTCH
SKIPE FILNAM↔GO L1
CALL(GETCHR)↔ANDI 1,17↔DAC 1,FONT ;FONT NUMERAL.
CALL(GETFIL)↔GO L3 ;FONT FILE NAME.
;FIND FONT FILE.
L1: LOOKUP 1,FILNAM↔GO[
LACI'FNT'↔SKIPN EXTION↔DIPZ EXTION
LOOKUP 1,FILNAM↔GO[
LAC FNTPPN↔SKIPN PPPN↔DAC PPPN
LOOKUP 1,FILNAM↔GO[
OUTSTR[ASCIZ/ FONT NOT FOUND.
/]↔ GO L3]↔GO .+1]↔GO .+1]
L2: LAC 1,FONT ;FONT NUMBER.
LAC MAXADR↔DAC FONTAB(1) ;FONT BASE ADDRESS.
HLL PPPN↔SOS↔DAC INARG ;IOWD DUMP ARGUMENT.
MOVS PPPN↔MOVMS↔ADD MAXADR↔AOS ;TOP OF THE FONT.
DAC MAXADR↔CORE2↔HALT ;EXPAND UPPER SEGMENT.
IN 1,INARG
CALL(SETFNT)
L3: RELEASE 1,
POP0J
↑FONTCH: 0
MAXADR: %+4000
INARG:0↔0
BEND DEFONT;2/7/73(TVR)2/25/73(BGB)-------------------------------
SUBR(SETFNT) SETUP A FONT.
BEGIN SETFNT;_____________________________________________________
LAC 1,FONT↔CDR 2,FONTAB(1) ;GET FONT BASE ADDRESS.
SKIPN 2↔POP0J ;EXIT WHEN FONT MISSING.
LACI =40↔DAC DROW ;LINE FEED DEFAULT.
SKIPE 1,201(2)↔DAC 1,DROW ;LINE FEED SPECIFIED.
LACI 5↔ADDM DROW
LACI =25↔DAC DCOL ;SPACE DEFAULT.
SKIPE 1,202(2)↔DAC 1,DCOL ;SPACE SPECIFIED.
SOS DCOL
POP0J
BEND SETFNT;2/7/72(TVR)-------------------------------------------
XFONT: CALL(GETCHR) ;SELECT FONT.
SETZM CMODE ;ENTER TEXT MODE.
CAIN"."↔POP0J ;NO CHANGE.
CAIGE 1,"0"↔POP0J
CAIG 1,"9"↔ANDI 1,17
CAIL 1,"A"↔GO[ANDI 1,37↔ADDI 1,=9↔GO .+1]
DAC 1,FONT↔SKIPE FONTAB(1)↔POP0J ;IS IT LOADED YET.
LAC FNTNAM(1)↔DAC FILNAM
LAC[SIXBIT/FNT/]↔DAC EXTION
LAC FNTPPN↔DAC PPPN
CALL(<DEFONT+1>)
POP0J
;____________________________________________________________________
;FONT SELECT DELIMITERS.
FSD:BLOCK 7
;FIVE PAIRS: {} () [] ⊂⊃ ≤≥
;DECLARE FONT SELECT DELIMITER.
DFS: GO .+6↔GO .+5↔GO .+4
GO .+3↔GO .+2↔GO .+1
SUBI DFS↔ADDI FSD
CALL(GETCHR)
CAIGE 1,"0"↔POP0J
CAIG 1,"9"↔ANDI 1,17
CAIL 1,"A"↔GO[ANDI 1,37↔ADDI 1,=9↔GO .+1]
DIP 1,@↔SKIPE FONTAB(1)↔POP0J ;IS IT LOADED YET.
PUSH P,FONT↔DAC 1,FONT
LAC FNTNAM(1)↔DAC FILNAM
LAC[SIXBIT/FNT/]↔DAC EXTION
LAC FNTPPN↔DAC PPPN
CALL(<DEFONT+1>)↔POP P,FONT
POP0J
;LEFT FONT SELECT DELIMITER - TEXT MODE SELECT FONT.
LFS: GO .+6↔GO .+5↔GO .+4
GO .+3↔GO .+2↔GO .+1
SUBI LFS↔ADDI FSD
CAR 1,@↔SKIPN 1↔GO PRINT
EXCH 1,FONT↔DAP 1,@ ;SAVE RETURN FONT NUMBER.
CALL(SETFNT)
POP0J
;RIGHT FONT SELECT DELIMITER - TEXT MODE RESTORE FONT.
RFS: GO .+6↔GO .+5↔GO .+4
GO .+3↔GO .+2↔GO .+1
SUBI RFS↔ADDI FSD
CDR 1,@↔SKIPN 1↔GO PRINT
DAC 1,FONT
CALL(SETFNT)
POP0J
; --- ASCII 00 TO 37.
A00:
0 ;null. ;00-07.
0 ;"↓"
0 ;"α"
0 ;"β"
0 ;"∧"
0 ;"¬"
0 ;"ε"
0 ;"π"
0 ;"λ" ;10↔17.
XWD HTAB,0 ;tab.
XWD LFEED,0 ;LF
0 ;VT.
XWD FFEED,0 ;FF.
XWD CRETURN,0 ;CR.
0 ;"∞"
0 ;"∂"
XWD LFS+4,DFS+4 ;"⊂" LEFT FONT SELECT DELIMITER ;20-27.
XWD RFS+4,0 ;"⊃" RIGHT FONT SELECT DELIMITER
0 ;"∩"
0 ;"∪"
0 ;"∀"
0 ;"∃"
IIISIM ;"⊗" III DISPLAY BUFFER - CORNER ORIGIN.
XARROW ;"↔"
0 ;"_" ;30-37.
XARROW ;"→"
XWD ESCAPE,0 ;"~" TILDE.
0 ;"≠"
XWD LFS+5,DFS+5 ;"≤" LEFT FONT SELECT DELIMITER
XWD RFS+5,0 ;"≥" RIGHT FONT SELECT DELIMITER
0 ;"≡"
0 ;"∨"
; --- ASCII 40 TO 77.
0 ;SPACE. ;40-47.
0 ;"!"
0 ;"""
0 ;"#"
0 ;"$"
0 ;"%"
0 ;"&"
0 ;"'"
XWD LFS+2,DFS+2 ;"(" LEFT FONT SELECT DELIMITER ;50-57.
XWD RFS+2,0 ;")" RIGHT FONT SELECT DELIMITER
IIISIM ;"*" III DISPLAY BUFFER - CENTER ORIGIN.
0 ;"+"
0 ;","
0 ;"-"
0 ;"."
0 ;"/"
0 ;"0" ;60-67.
0 ;"1"
0 ;"2"
0 ;"3"
0 ;"4"
0 ;"5"
0 ;"6"
0 ;"7"
0 ;"8" ;70-77.
0 ;"9~
0 ;":~
SEMICO ;";~
0 ;"<"
0 ;"="
0 ;">"
0 ;"?"
; --- ASCII 100 TO 137. UPPER CASE COMMANDS.
INFILE ;"@" INDIRECT FILE COMMAND ;100-107.
XARROW ;"A"
0 ;"B"
XCONIC ;"C" CONIC ARCS
[SETOM BUGFLG↔POP0J] ;"D" DEBUG FLAG.
XCONIC ;"E"
XFONT ;"F" SELECT FONT AND ENTER TEXT MODE.
0 ;"G"
XCONIC ;"H" ;110-117.
AI ;"I" ABSOLUTE INVISIBLE VECTOR.
0 ;"J"
0 ;"K"
XLOCUS ;"L"
XMARGN ;"M" MARGINS.
DEFONT ;"N" NAME FONT NUMBER.
XROTAT ;"O" SET ORIENTATION.
0 ;"P" ;120-127.
0 ;"Q"
XRADIAL ;"R"
0 ;"S"
0 ;"T"
0 ;"U"
AV ;"V" ABSOLUTE VISIBLE VECTOR.
0 ;"W"
XXSCAL ;"X" SET X SCALE. ;130-137.
YYSCAL ;"Y" SET Y SCALE.
0 ;"Z"
XWD LFS+3,DFS+3 ;"[" LEFT FONT SELECT DELIMITER
0 ;"\"
XWD RFS+3,0 ;"]" RIGHT FONT SELECT DELIMITER
0 ;"↑"
XARROW ;"←"
; --- ASCII 140 TO 177. LOWER CASE COMMANDS.
0 ;"'" ;140-147.
0 ;"a"
0 ;"b"
0 ;"c"
0 ;"d"
0 ;"e"
0 ;"f"
0 ;"g"
0 ;"h" ;150-157.
0 ;"i"
0 ;"j"
0 ;"k"
0 ;"l"
0 ;"m"
0 ;"n"
0 ;"o"
0 ;"p" ;160-167.
0 ;"q"
0 ;"r"
0 ;"s"
0 ;"t"
0 ;"u"
0 ;"v"
0 ;"w"
0 ;"x" ;170-177.
0 ;"y"
0 ;"z"
XWD LFS+1,DFS+1 ;"{" LEFT FONT SELECT DELIMITER
0 ;"|"
0 ;alt
XWD RFS+1,0 ;"}" RIGHT FONT SELECT DELIMITER
0 ;rubout
;COMMAND EXECUTION.
;____________________________________________________________________
;ABSOLUTE INVISIBLE VECTOR.
AI: CALL(GETNUM)↔DAC 1,ROW
CALL(GETNUM)↔DAC 1,COL↔POP0J
;____________________________________________________________________
;ABSOLUTE VISIBLE VECTOR.
AV: CALL(GETNUM)↔DAC 1,4
CALL(GETNUM)↔DAC 1,5
SKIPE ARROW1↔GO[CALL(MKARROW,4,5)↔POP P,5↔POP P,4↔GO .+1]
LAC 2,ROW↔LAC 3,COL
DAC 4,ROW↔DAC 5,COL
SKIPE ARROW2↔GO[CALL(MKARROW,2,3)↔POP P,3↔POP P,2↔GO .+1]
LAC 4,ROW↔LAC 5,COL
SETO↔CALL(MKSEG0)↔POP0J
;____________________________________________________________________
XMARGN: CALL(GETNUM)↔DAC 1,LMAR
POP0J
XRADIAL:
CALL(GETNUM)↔DAC 1,5↔FLOAT 5,↔DAC 5,4
CALL(GETNUM)↔DAC 1,3↔FLOAT 3,↔DAC 3,2
FMP 2,SINE↔MOVNS 2↔FIXX 2,↔ADD 2,ROW
FMP 4,SINE↔MOVNS 4↔FIXX 4,↔ADD 4,ROW
FMP 3,COSINE↔FIXX 3,↔ADD 3,COL
FMP 5,COSINE↔FIXX 5,↔ADD 5,COL
SETO↔CALL(MKSEG0)↔POP0J
;____________________________________________________________________
SEMICO: DZM ARROW1↔DZM ARROW2↔POP0J
;____________________________________________________________________
XARROW: CAIE 1,"↔"↔GO .+3
SETOM ARROW1↔SETOM ARROW2
CAIN"←"↔SETOM ARROW1
CAIN"→"↔SETOM ARROW1
POP0J
SUBR(MKARROW)ROW2,COL2
LAC 0,ARG1↔SUB 0,COL↔FLOAT 0,↔DAC 0,10↔FMP 0,0
LAC 1,ARG2↔SUB 1,ROW↔FLOAT 1,↔DAC 1,11↔FMP 1,1
FAD 1,0↔CALL(SQRT,1)
PUSH P,SINE↔PUSH P,COSINE ;SAVE OLDE ORIENTATION.
LAC 10↔FDV 1↔DAC COSINE
LAC 11↔FDV 1↔DACN SINE
SETZB 2,3↔LAC 4,ARROWL↔LAC 5,ARROWW↔CALL(MKSEG3)
SETZB 2,3↔LAC 4,ARROWL↔LACN 5,ARROWW↔CALL(MKSEG3)
LAC 2,ARROWL↔LAC 3,ARROWW
LAC 4,ARROWL↔LACN 5,ARROWW↔CALL(MKSEG3)
POP P,COSINE↔POP P,SINE
POP0J
ARROW1: 0 ;ARROW HEAD 1ST VERTEX - PREFIX FLAG.
ARROW2: 0 ;ARROW HEAD 2ND VERTEX - PREFIX FLAG.
ARROWW: 15.0 ;ARROW HALF WIDTH.
ARROWL: 45.0 ;ARROW LENGTH.
;III DISPLAY SCALE FACTOR.
XXSCAL: CALL(REALIN)↔DAC SCALEX
FMPR[1024.]↔FIXX↔DAC IIIDX
POP0J
YYSCAL: CALL(REALIN)↔DAC SCALEY
FMPR[1024.]↔FIXX↔DAC IIIDY
POP0J
XROTAT: CALL(READARC)↔DAC ROTDEL
SETQ(SINE,{SIN,ROTDEL})
SETQ(COSINE,{COS,ROTDEL})
POP0J
;____________________________________________________________________
SUBR(XLOCUS) ;L<X>,<Y>
CALL(REALIN)↔FADR[864.0]↔FIXX↔DAC COL
CALL(REALIN)↔FSBR[1024.0]↔FIXX↔DACN ROW
POP0J
SUBR(MODE0)
BEGIN MODE0;
CALL(GETCHR) ;GET MODE 0 ESCAPE
DAC 1,CHAR ;SAVE IT IN CASE ITS A HIDDEN CHARACTER
JUMPE 1,HIDDEN
CAIN 1,1↔GO ESC1
CAIN 1,2↔GO ESC2
CAIL 1,20 ;TREAT '177 '20 THRU '177 '24 AS LINE SPACE
CAILE 1,24
GO [ LAC DCOL↔ADDM COL↔GO COLCHK ]
GO HIDDEN
COMMENT ⊗
XGP ESCAPE 1 ('177&'001) causes the next 7 bits to be read as a special
operation code. The following codes are proposed:
0-17 Font select. The code, 0 to 17 is taken as the font
identification number of the font to use.
20-37 Reserved for future use.
40 XGP Column Selector
The next 14 bits are taken modulo 4096 as the x position
to print at next. (The intention is to allow arbitrary
width spaces for text justification.)
41 XGP Underscore
The next 7 bits are taken as the scan line number on which
to underscore. (Scan line 0 is the first scan-line in the
character). The next 14 bits are taken modulo 4096 as the
length of the underscore.
42 Line space.
This does a line feed and then takes the next 7 bits as the
number of blank lines to insert before the next line.
43 Base-line adjust.
The next 7 bits are taken in two's complement as the base-
line adjustment to the current font. The adjustment sticks
until reset by another adjust command or a font select. The
intention is to allow a font to be used for subscripts and
superscripts. (Increment baseline for superscript, decrement
for subscript).
44 Insert the paper page number. The paper page number is set
to 1 by a form feed. It is incremented each time the paper
is cut. This escape causes the decimal value of this count
to be printed.
45 Accept heading text. The next byte is a count of bytes to
follow. That number of bytes will be read into the heading
line. When that count is exhausted, the heading line will
be printed.
⊗;
ESC1: CALL(GETCHR)
CAIGE 1,20↔GO [ DAC 1,FONT↔POP0J ]
CAIN 1,40↔GO COLSEL
CAIN 1,41↔GO UNDERSCORE
CAIN 1,42↔GO LINESPACE
FATAL(UNIMPLIMENT MODE 0 COMMAND)
COLSEL: CALL(GET14)
DAC 1,COL
GO COLCHK
UNDERSCORE: FATAL(UNDERSCORE UNIMPLIMENTED)
LINESPACE: CALL(GETCHR)
ADD DROW
ADDM ROW
GO ROWCHK
COMMENT ⊗
XGP ESCAPE 2 ('177&'002) causes the next 7 bits to be taken as the column
increment. This quantity is signed: 0-77 are positive increments 100
to 177 are negative increments (100 → -100, 177 → -1).
The escape significance of codes 3 through 10, 13, and 16 through 37 is not
defined at the present time but reserved for future use.
⊗;
ESC2: CALL(GETCHR)
CAIL 1,100
OR 1,[ 777777777700 ]
ADDM 1,COL
GO COLCHK
BEND MODE0;
;SUBR(SQRT)
SUBR(SQRT)--------------------------------------------------------
BEGIN SQRT;MODIFIED OLDE LIB40 SQUARE ROOT - BGB - TRADITIONAL.
A←0 ↔ B←1 ↔ C←2
MOVM B,ARG1↔JUMPE B,POP1J.↔PUSH P,2
;LET X=F*(2↑2B) WHERE 0.25<F<1.00 THEN SQRT(X)=SQRT(F)*(2↑B).
ASHC B,-=27↔SUBI B,201 ;GET EXPONENT IN B, FRACTION IN C.
ROT B,-1 ;CUT EXP IN HALF, SAVE ODD BIT
HRRM B,L↔LSH B,-=35 ;USE THAT ODD BIT.
ASH C,-10↔FSC C,177(B) ;0.25 < FRACTION < 1.00
;LINEAR APPROXIMATION TO SQRT(F).
MOVEM C,A
FMP C,[0.8125↔0.578125](B)
FAD C,[0.302734↔0.421875](B)
;TWO ITERATIONS OF NEWTON'S METHOD.
MOVE B,A
FDV B,C↔FAD C,B↔FSC C,-1
FDV A,C↔FADR A,C
L: FSC A,0↔MOVE 1,A↔POP P,2
POP1J↔LIT
BEND;28/12/72-----------------------------------------------------
BEGIN SINCOS ;SINE & COSINE - BGB.
INTERN SIN,COS;---------------------------------------------------
A←1 ↔ B←2 ↔ C←3
↑COS: SKIPA A,ARG1
↑SIN: SKIPA A,ARG1
FADR A,HALFPI ;COS(X) = SIN(X+π/2).
MOVM B,A↔CAMG B,[17B5]↔POP1J ;FOR SMALL X, SIN(X)=X.
;B ← (ABS(X)MODULO 2π)/HALFPI
;C ← QUADRANT 0, 1, 2 OR 3.
FDVR B,HALFPI
LAC C,B↔FIX C,233000
CAILE C,3↔GO[
TRZ C,3↔FSC C,233
FSBR B,C↔GO .-3] ;MODULO 2π.
GO .+1(C)↔GO .+4↔JFCL↔GO[
FSBRI B,(2.0)↔MOVNS B↔GO .+2] ;SIN(X+π)=SIN(-X)
FSBRI B,(4.0) ;SIN(X+2π)=SIN(X)
SKIPGE A↔MOVNS B ;SIN(-X) = -SIN(X).
;FOR -1 ≤ B ≤ +1 REPRESENTING -π/2 ≤ X ≤ +π/2,
;COMPUTE SINE(X) APPROXIMATION BY TAYLOR SERIES.
DAC B,C↔FMPR B,B
LAC A,[164475536722]↔FMP A,B
FAD A,[606315546346]↔FMP A,B
FAD A,[175506321276]↔FMP A,B
FAD A,[577265210372]↔FMP A,B
FAD A,HALFPI↔FMPR A,C↔POP1J
HALFPI: 201622077325 ;PI/2
LIT
BEND;-------------------------------------------------------------
SUBR(READARC)
CALL(REALIN)↔JUMPL[CAMG[6.3]↔FMPR[0.0174533]↔POP0J]
CAML[6.3]↔FMPR[0.0174533]↔POP0J
SUBR(REALIN)
BEGIN REALIN;
;<EXPR> ::= <EXPR>+<TERM>|<EXPR>-<TERM>|<TERM>
;<TERM> ::= <TERM>*<PRIMARY>|<TERM>/<PRIMARY>|<PRIMARY>
;<PRIMARY> ::= -<PRIMARY>|(<EXPR>)||π|<REAL NUMBER>
CALL(TERM)
CAIN 1,"+"↔GO[
PUSH P,0↔CALL(TERM)↔FADR 0,(P)
SUB P,[XWD 1,1]↔GO REALIN+1]
CAIN 1,"-"↔GO[
PUSH P,0↔CALL(TERM)↔MOVN 0,0↔FADR 0,(P)
SUB P,[XWD 1,1]↔GO REALIN+1]
POP0J↔POP0J
TERM: CALL(PRIMARY)
TERM2: CAIN 1,"*"↔GO[
PUSH P,0↔CALL(PRIMARY)↔FMPR 0,(P)
SUB P,[XWD 1,1]↔GO TERM2]
CAIN 1,"/"↔GO[
PUSH P,0↔CALL(PRIMARY)↔EXCH 0,(P)↔FDVR 0,(P)
SUB P,[XWD 1,1]↔GO TERM2]
POP0J
;BEGIN REALIN ; INPUT SMALL REAL NUMBER - BGB - 16 DEC 1972
;AC-0 INTEGER ACCUMULATION. AC-0 RETURNS REAL NUMBER.
;AC-1 CHARACTER. AC-1 RETURNS BREAK CHARACTER.
;AC-2 COUNTER OF DIGITS TO RIGHT OF DECIMAL POINT PLUS ONE.
;AC-3 MINUS SIGN FLAG.
PRIMARY:SETZ↔SETZB 2,3
L0: CALL(GETCHR)
CAIN 1," "↔GO .-2
CAIN 1,"-"↔GO[SETCMM 3↔GO L0]
CAIN 1,"π"↔GO[MOVE 0,[3.1415926]
GETRET: CALL(GETCHR)↔GO L3]
CAIN 1,"("↔GO[PUSH P,3↔CALL(REALIN)↔POP P,3
CAIN 1,")"↔GO GETRET
OUTSTR[ASCIZ/WARNING: MISSING ')'
/]↔ POP0J]
SKIPA
L1: CALL(GETCHR)
CAIN 1,";"↔GO L2↔CAIN 1,","↔GO L2
CAIE 1,"."↔GO .+3↔JUMPN 2,L2↔AOJA 2,L1
CAIL 1,"0"↔CAILE 1,"9"↔GO L2
JUMPN 2,[CAILE 2,4↔GO L1↔AOJA 2,.+1]
ANDI 1,17↔IMULI =10↔ADD 1↔GO L1
L2: FLOAT↔SOSLE 2↔FDVR[1.0↔10.0↔100.0↔1000.0↔10000.0](2)
L3: SKIPE 3↔MOVNS↔POP0J
BEND REALIN;12/16/72(BGB),14-MAR-73(TVR)-----------------------------
SUBR(DPYDOT)X,Y ;DISPLAY A DOT.
BEGIN DPYDOT
;PLACE A DOT AT LOCUS (X,Y).
;DILATION, ROTATION, TRANSLATION, & CLIP.
ACCUMULATORS{R,C}
LAC R,ARG1↔LAC C,ARG2
FMP R,SCALEY↔LAC 0,R ;DILATION.
FMP C,SCALEX↔LAC 1,C
FMP 0,SINE↔FMP R,COSINE ;ROTATION.
FMP 1,SINE↔FMP C,COSINE
FADR R,1↔FSBR C,0↔MOVNS R
FIXX R,↔ADD R,ROW ;TRANSLATION.
FIXX C,↔ADD C,COL
CAMGE R,QLO↔POP2J ;CLIP.
CAMLE R,QHI↔POP2J
SKIPGE C↔POP2J
CAILE C,=1728
SETO↔DOT(R,C)↔POP2J ;DISPLAY.
BEND DPYDOT;BGB 29 MAY 1973._________________________________________
SUBR(MKSEG3)
BEGIN MKSEG3
R←←2 ↔ C←←3
EXCH R,C
FMP R,SCALEY↔LAC 0,R ;DILATION.
FMP C,SCALEX↔LAC 1,C
FMP 0,SINE↔FMP R,COSINE ;ROTATION.
FMP 1,SINE↔FMP C,COSINE
FADR R,1↔FSBR C,0↔MOVNS R
FIXX R,↔ADD R,ROW ;TRANSLATION.
FIXX C,↔ADD C,COL
R←←4 ↔ C←←5
EXCH R,C
FMP R,SCALEY↔LAC 0,R ;DILATION.
FMP C,SCALEX↔LAC 1,C
FMP 0,SINE↔FMP R,COSINE ;ROTATION.
FMP 1,SINE↔FMP C,COSINE
FADR R,1↔FSBR C,0↔MOVNS R
FIXX R,↔ADD R,ROW ;TRANSLATION.
FIXX C,↔ADD C,COL
SETO↔GO MKSEG0
BEND MKSEG3;_________________________________________________________
SUBR(XCONIC) ;E<A>,<B>,<X1>,<X2>;
BEGIN XCONIC
SLACI(<1.0>)↔CAIE 1,"H"↔MOVNS↔DAC ONE
CALL(REALIN)↔DACM A#
CALL(REALIN)↔DACM B#
CALL(REALIN)↔DAC X1#
CALL(REALIN)↔DAC X2#
LACI CONIC↔DAP FN ;FUNCTION ARGUMENT.
CALL(CONIC,X1)↔DAC 1,Y1#
CALL(CONIC,X2)↔DAC 1,Y2#
LAC 2,X1↔LAC 3,Y1
LAC 4,X2↔LAC 5,Y2
CALL(MKCURV)↔POP0J
CONIC: LAC 1,ARG1↔FDV 1,A↔FMP 1,1
FADR 1,ONE↔CALL(SQRT,1)↔FMP 1,B↔POP1J
ONE: 1.0
BEND XCONIC;_________________________________________________________
FN:GO
SUBR(MKCURV)
BEGIN MKCURV
ACCUMULATORS{X1,Y1,X2,Y2}
PUSH P,X1↔PUSH P,Y1
FADR X1,X2↔FSC X1,-1
FADR Y1,Y2↔FSC Y1,-1
CALL(FN,X1)↔EXCH 1,Y1
FSB 1,Y1↔MOVMS 1↔CAMGE 1,[1.5]↔GO L1
LAC 1,X1↔FSB 1,X2↔MOVMS 1↔CAMGE 1,[1.0]↔GO L1
CALL(MKCURV) ;MIDPOINT TO 2ND END.
LAC X2,-1(P)↔LAC Y2,0(P)
CALL(MKCURV) ;MIDPOINT TO 1ST END.
POP P,Y1↔POP P,X1↔POP0J
L1: LAC X1,-1(P)↔LAC Y1,0(P)
CALL(MKSEG3)
POP P,Y1↔POP P,X1↔POP0J
BEND MKCURV;_________________________________________________________
END SA